PC Plus SuperCD (UK) 1997 February/PC Plus Super CD (Issue 124) (PCP124-2-97) (February 1997).iso/ms/vb5cce/controls/samples/clrbox2/clrbox2.exe/ClrBox2.ctl

Text File | 1996-10-25 | 8.7 KB | 253 lines

VERSION 5.00
Begin VB.UserControl ColorBox2
   Appearance      =   0  'Flat
   AutoRedraw      =   -1  'True
   BackColor       =   &H8000000A&
   ClientHeight    =   3600
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   4800
   PropertyPages   =   "ClrBox2.ctx":0000
   ScaleHeight     =   3600
   ScaleWidth      =   4800
   ToolboxBitmap   =   "ClrBox2.ctx":0004
   Begin VB.Shape shpBox
      BorderColor     =   &H00FF8000&
      Height          =   3375
      Left            =   120
      Top             =   120
      Width           =   4575
   End
End
Attribute VB_Name = "ColorBox2"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
'This version of ColorBox uses a timer class written
'by Mike Wills.  It allows you to create more instances
'of ColorBox than a timer control does.

Option Explicit

Private WithEvents timBoxMove As clsTimer 'The timer class
Attribute timBoxMove.VB_VarHelpID = -1

Private boolWiden As Boolean 'Are we expanding or contracting?
Private boolLengthen As Boolean 'Are we expanding or contracting?
Private intOrigWidth As Integer 'Original width of box
Private intOrigHeight As Integer 'Original height of box

Private Const RedOffset As Long = &H1 'Value used to extract Red portion of Color value
Private Const GreenOffset As Long = &H100 'Value used to extract Green portion of Color value
Private Const BlueOffset As Long = &H10000 'Value used to extract Blue portion of Color value

Private Const RedMax As Byte = 255 'The maximum red value
Private Const RedMin As Byte = 0 'The minimum red value
Private Const GreenMax As Byte = 255 'The maximum green value
Private Const GreenMin As Byte = 0 'The minimum green value
Private Const BlueMax As Byte = 255 'The maximum blue value
Private Const BlueMin As Byte = 0 'The minimum blue value

'Color change increments
Private Const ColorIncr As Integer = 1
Private Const ColorDecr As Integer = -1

'Margin widths between the edge of the usercontrol and the box.
Private Const LeftMargin As Single = 5
Private Const TopMargin As Single = 5
Private Const RightMargin As Single = 5
Private Const BottomMargin As Single = 5

Event BoxColorChange(NewColor As Long) 'Event that fires when the box color changes

'Writing the BoxColor Property.
Public Property Let BoxColor(Color As OLE_COLOR)
    shpBox.BorderColor = Color
End Property

'Reading the BoxColor Property.
Public Property Get BoxColor() As OLE_COLOR
    BoxColor = shpBox.BorderColor
End Property

'Writing the Enabled Property.
Public Property Let Enabled(ByVal AreWeOn As Boolean)
    timBoxMove.Enabled = AreWeOn
End Property

'Reading the Enabled Property.
Public Property Get Enabled() As Boolean
    Enabled = timBoxMove.Enabled
End Property

'Writing the Interval Property.
Public Property Let Interval(ByVal HowFast As Integer)
    timBoxMove.Interval = HowFast
End Property

'Reading the Interval Property.
Public Property Get Interval() As Integer
    Interval = timBoxMove.Interval
End Property

Private Sub UserControl_AmbientChanged(PropertyName As String)
    If PropertyName = "BackColor" Then BackColor = Ambient.BackColor
End Sub

Private Sub UserControl_InitProperties()
    'Initializing BoxColor (Default = A nice shade of blue)
    BoxColor = RGB(0, 128, 256)
    'Initializing Enabled (Default = False)
    Enabled = False
    'Initializing Interval (Default = 50 milliseconds)
    Interval = 50
End Sub

'This loads the current values of your persistent properties
'If a value has not been set, it loads a default value
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
    'Loading BoxColor (Default = A nice shade of blue)
    BoxColor = PropBag.ReadProperty("BoxColor", 16744448)
    'Loading Enabled (Default = False)
    Enabled = PropBag.ReadProperty("Enabled", False)
    'Loading Interval (Default = 50 milliseconds)
    Interval = PropBag.ReadProperty("Interval", 50)
End Sub

'This saves the value of your persistent properties if you change them
'in design mode
Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
    'Saving BoxColor
    PropBag.WriteProperty "BoxColor", BoxColor
    'Saving Enabled
    PropBag.WriteProperty "Enabled", Enabled
    'Saving Interval
    PropBag.WriteProperty "Interval", Interval
End Sub

'This routine changes the size of the box and changes the color.  Red, Green
'and Blue values are calculated independently.  They cycle between 0 and 255
'starting with the initial value of BoxColor.
Private Sub timBoxMove_Timer()
    Dim I            As Integer
    Dim wthBox       As Single 'Width of box
    Dim hgtBox       As Single 'Height of box
    Dim lftBox       As Single 'Left border of box
    Dim topBox       As Single 'Top border

    Dim clrBorderCol As Long 'The full 24 bit bordercolor
    Dim cRed         As Byte 'The red portion of clrBorderCol
    Dim cGreen       As Byte 'The green portion of clrBorderCol
    Dim cBlue        As Byte 'The blue portion of clrBorderCol

    Static iRed      As Integer 'The value added to the red portion of clrBorderCol
    Static iGreen    As Integer 'The value added to the green portion of clrBorderCol
    Static iBlue     As Integer 'The value added to the blue portion of clrBorderCol


    With shpBox
        wthBox = .Width
        hgtBox = .Height
        lftBox = .Left
        topBox = .Top
        clrBorderCol = .BorderColor
        cRed = ((clrBorderCol \ RedOffset) And &HFF) 'Extract red portion of BorderColor
        cGreen = ((clrBorderCol \ GreenOffset) And &HFF) 'Extract green portion of BorderColor
        cBlue = ((clrBorderCol \ BlueOffset) And &HFF) 'Extract blue portion of BorderColor

        For I = 1 To 2

            If wthBox < 5 And boolWiden = False Then boolWiden = True
            If ((wthBox + 5) >= intOrigWidth Or lftBox < 5) And _
                boolWiden = True Then boolWiden = False
            If hgtBox < 5 And boolLengthen = False Then boolLengthen = True
            If ((hgtBox + 5) >= intOrigHeight Or topBox < 5) And _
                boolLengthen = True Then boolLengthen = False

            If boolWiden = False Then
                lftBox = lftBox + 1
                wthBox = wthBox - 2
            Else
                lftBox = lftBox - 1
                wthBox = wthBox + 2
            End If
            If boolLengthen = False Then
                topBox = topBox + 1
                hgtBox = hgtBox - 2
            Else
                topBox = topBox - 1
                hgtBox = hgtBox + 2
            End If

            .Move lftBox, topBox, wthBox, hgtBox
        Next I



        If cRed = RedMax Then
            iRed = ColorDecr
        Else
            If cRed = RedMin Then
                iRed = ColorIncr
            Else
                If iRed = 0 Then
                    If cRed < 255 Then iRed = ColorIncr Else iRed = ColorDecr
                End If
            End If
        End If

        If cGreen = GreenMax Then
            iGreen = ColorDecr
        Else
            If cGreen = GreenMin Then
                iGreen = ColorIncr
            Else
                If iGreen = 0 Then
                    If cGreen < GreenMax Then iGreen = ColorIncr Else iGreen = ColorDecr
                End If
            End If
        End If

        If cBlue = BlueMax Then
            iBlue = ColorDecr
        Else
            If cBlue = BlueMin Then
                iBlue = ColorIncr
            Else
                If iBlue = 0 Then
                    If cBlue < BlueMax Then iBlue = ColorIncr Else iBlue = ColorDecr
                End If
            End If
        End If

        .BorderColor = RGB(cRed + iRed, cGreen + iGreen, cBlue + iBlue)
        RaiseEvent BoxColorChange(.BorderColor)
    End With
End Sub

Private Sub UserControl_Initialize()
    ScaleMode = vbPixels 'Pixels
    intOrigWidth = shpBox.Width 'Record original width
    intOrigHeight = shpBox.Height 'Record original height

    Set timBoxMove = New clsTimer 'instanciate timer class
End Sub

Private Sub UserControl_Resize()
    'Reset box shape
    shpBox.Move LeftMargin, TopMargin, Abs((Width / Screen.TwipsPerPixelX) - RightMargin), Abs((Height / Screen.TwipsPerPixelY) - BottomMargin)
End Sub

Private Sub UserControl_Show()
    BackColor = Ambient.BackColor
End Sub

Private Sub UserControl_Terminate()
    If Not timBoxMove Is Nothing Then
        If timBoxMove.Enabled Then timBoxMove.Enabled = False
        Set timBoxMove = Nothing
    End If
End Sub